Я выбрал первую задачу:
С точки зрения потенциального заказчика нужно:
Это нужно сделать, чтобы путем определенных действий уменьшить поток оттока клиентов, чтобы увеличить прибыль банка.
Подключение к базе.
library(DBI)
library(RMariaDB)
con <- dbConnect(RMariaDB::MariaDB(),
user='student2022minor',
password='DataMinorHSE!2020',
dbname='bank',
host='hsepiterdata-1.cqq6v5igyw1z.us-east-2.rds.amazonaws.com',
port = 3315)
dbListTables(con)
## [1] "country" "profile" "portfolio"
В этом проекте мы будем работать с таблицами “country”, “profile” и “portfolio” Давайте посмотрим, какие группы клиентов чаще всего уходят из банка.
exited = dbGetQuery(con, "SELECT Exited, Gender, Age, EstimatedSalary, Tenure,
Balance, NumOfProducts, HasCrCard, CreditScore
FROM portfolio INNER JOIN profile
ON portfolio.CustomerId = profile.CustomerId")
Преобразуем типы
library(dplyr)
exited = exited %>%
mutate(Exited = case_when(Exited == 0 ~ "No",
TRUE ~ "Yes")) %>%
mutate(HasCrCard = case_when(HasCrCard == 0 ~ "No",
TRUE ~ "Yes"))
exited = exited %>% mutate_if(is.character, as.factor)
Преобразуем факторы в числа (дамми-переменные)
exitedNum = fastDummies::dummy_cols(exited, remove_first_dummy = TRUE)
exitedNum = exitedNum %>% select(-Exited, -Gender, -HasCrCard)
Считаем разделение на кластеры
set.seed(666)
km = kmeans(scale(exitedNum), centers = 5)
exitedNum$cluster = km$cluster
И финальное описание
exitedNum %>% group_by(cluster) %>% summarise_all(mean)
## # A tibble: 5 × 10
## cluster Age Estimat…¹ Tenure Balance NumOf…² Credi…³ Exite…⁴ Gende…⁵ HasCr…⁶
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 37.4 99664. 5.14 108546. 1.31 651. 0 1 1
## 2 2 37.4 99015. 5.16 2104. 2.07 653. 3.74e-2 0.563 0.989
## 3 3 37.5 100381. 4.91 105386. 1.32 651. 0 0 1
## 4 4 45.0 101086. 4.94 93772. 1.41 645. 1 e+0 0.439 0.693
## 5 5 37.5 100353. 4.91 74558. 1.53 652. 4.31e-4 0.568 0
## # … with abbreviated variable names ¹EstimatedSalary, ²NumOfProducts,
## # ³CreditScore, ⁴Exited_Yes, ⁵Gender_Male, ⁶HasCrCard_Yes
Мы можем наблюдать кластер под номером 4, где все клиенты ушли из банка. Из отличительных показателей этого кластера можно отметить:
возраст - он в среднем выше, чем в других кластерах
кредитный скоринг клиента - он в среднем меньше, чем в других кластерах
пол - в среднем чаще уходят женщины (вывод сделан на основе того, что Gender_Male меньше половины)
есть ли кредитная карта - у ушедших клиентов в среднем меньше кредитных карт, чем в остальных кластерах, за исключением 5.
Посмотрим, правда ли, что женщины в целом уходят чаще из банка
data4 = dbGetQuery(con, "SELECT Exited, COUNT(*) AS n
FROM portfolio
GROUP BY Exited")
data5 = dbGetQuery(con, "SELECT Gender, COUNT(*) AS n
FROM portfolio INNER JOIN profile
ON portfolio.CustomerId = profile.CustomerId
WHERE Exited = 0
GROUP BY Gender")
data6 = dbGetQuery(con, "SELECT Gender, COUNT(*) AS n
FROM portfolio INNER JOIN profile
ON portfolio.CustomerId = profile.CustomerId
WHERE Exited = 1
GROUP BY Gender")
library(plotly)
plot_ly(
labels = c("Total", "Did not exit", "Exited", "Female", "Male",
"Female ", "Male "),
parents = c("", "Total", "Total", "Did not exit", "Did not exit", "Exited", "Exited"),
values = c(sum(data4$n), data4$n, data5$n, data6$n),
type = 'sunburst',
branchvalues = 'total'
)
Несмотря на то, что женщин в целом меньше, чем мужчин, они действительно уходят больше. На это обязательно стоит обратить внимание в дальнейшем!
Подводя итоги анализа на данный момент, для дальнейшего анализа стоит взять взять подгруппу со следующими критериями:
Женщины
Возраст выше среднего
Кредитный скоринг меньше среднего
Посчитаем медиану для возраста
res_age = dbGetQuery(con, "SELECT profile.CustomerId AS CustomerId, SUM(Age) AS TotalAge
FROM profile INNER JOIN portfolio
ON profile.CustomerId = portfolio.CustomerId
GROUP BY profile.CustomerId")
median_age = median(res_age$TotalAge)
median_age
## [1] 37
Медианный возраст составил 37 лет. Следовательно, будем фильтровать нашу подгруппу с условием, что возраст должен быть больше 37.
Теперь посчитаем медиану для кредитного скоринга
res_cs = dbGetQuery(con, "SELECT profile.CustomerId AS CustomerId, SUM(CreditScore) AS TotalCS
FROM profile INNER JOIN portfolio
ON profile.CustomerId = portfolio.CustomerId
GROUP BY profile.CustomerId")
median_cs = median(res_cs$TotalCS)
median_cs
## [1] 652
Медианный кредитный скоринг составил 652. Значит, будем фильтровать нашу подгруппу с условием, что кредитный скоринг должен быть меньше 652.
Теперь можем создать датафрейм со всеми нашими условиями и переменными для дальнейшего анализа.
final_exited = dbGetQuery(con, "SELECT Exited, Gender, Age, EstimatedSalary, Tenure,
Balance, NumOfProducts, HasCrCard, CreditScore
FROM profile INNER JOIN portfolio
ON profile.CustomerId = portfolio.CustomerId
GROUP BY profile.CustomerId
HAVING Gender = 'Female' AND Age > 37 AND CreditScore < 652")
Больше нам не нужно соединение с базой, поэтому закрываем соединение
dbDisconnect(con)
Преобразуем переменные character в factor и уберем переменную Gender, так как у нас все женщины
final_exited = final_exited %>% mutate_if(is.character, as.factor)
final_exited$Exited = as.factor(final_exited$Exited)
final_exited = final_exited %>% select(-Gender)
Строим модель “дерево”
library(partykit)
library(caret)
set.seed(100)
ind = createDataPartition(final_exited$Exited, p = 0.8, list = F)
train = final_exited[ind,]
test = final_exited[-ind,]
treemodel = ctree(Exited~., data = train)
plot(treemodel)
Мы можем заметить, что разбиение основывается на возрасте, но мы с ним ничего не можем сделать для уменьшения оттока. Нехороший знак…
Оцениваем качество модели
predTest = predict(treemodel, test)
confusionMatrix(predTest, test$Exited)
## Confusion Matrix and Statistics
##
## Reference
## Prediction 0 1
## 0 89 36
## 1 50 57
##
## Accuracy : 0.6293
## 95% CI : (0.5637, 0.6916)
## No Information Rate : 0.5991
## P-Value [Acc > NIR] : 0.1922
##
## Kappa : 0.247
##
## Mcnemar's Test P-Value : 0.1610
##
## Sensitivity : 0.6403
## Specificity : 0.6129
## Pos Pred Value : 0.7120
## Neg Pred Value : 0.5327
## Prevalence : 0.5991
## Detection Rate : 0.3836
## Detection Prevalence : 0.5388
## Balanced Accuracy : 0.6266
##
## 'Positive' Class : 0
##
В целом чутка лучше, чем рандомно самому определять классы (где accuracy составила бы 0.5 по теории вероятности), поэтому можем работать дальше
Построим модель логистической регрессии и оценим ее качество
library(tidymodels)
set.seed(100)
model = logistic_reg()
logreg = model %>% fit(Exited~., data = train)
predlog = predict(logreg, test)
table(predlog$.pred_class, test$Exited)
##
## 0 1
## 0 122 70
## 1 17 23
test %>%
mutate(pred =predlog$.pred_class) %>%
conf_mat(estimate = pred, truth = Exited) %>%
summary()
## # A tibble: 13 × 3
## .metric .estimator .estimate
## <chr> <chr> <dbl>
## 1 accuracy binary 0.625
## 2 kap binary 0.138
## 3 sens binary 0.878
## 4 spec binary 0.247
## 5 ppv binary 0.635
## 6 npv binary 0.575
## 7 mcc binary 0.162
## 8 j_index binary 0.125
## 9 bal_accuracy binary 0.563
## 10 detection_prevalence binary 0.828
## 11 precision binary 0.635
## 12 recall binary 0.878
## 13 f_meas binary 0.737
Здесь accuracy чуть поменьше, чем в предыдущей модели
Давайте оценим важность признаков
library(vip)
vip(treemodel)
vip(logreg)
У логистической регрессии гораздо больше важных переменных, по сравнению с деревом решений. Для дальнейшей симуляции будем использовать поэтому логистическую регрессию
Давайте посмотрим на распределение одного из важных признаков в логистической регрессии - NumOfProducts (количество продуктов у клиента) - в зависимости от того, уходил ли клиент или нет (смотрим и тестовую, и тренировочную выборки)
ggplot(train) + geom_bar(aes(x = NumOfProducts, fill = Exited), position = "fill")
ggplot(test) + geom_bar(aes(x = NumOfProducts, fill = Exited), position = "fill")
Можем заметить, что покинувшие банк клиенты чаще всего имеют 1 или 2 продукта от банка. Справедливости ради стоит также обратить внимание на то, что клиентов с 3 или 4 продуктами намного меньше, чем с 1 или 2, но при этом действитетельно их обладатели больше склонны уходить из банка.
Давайте попробуем увеличить количество продуктов на 1 для тех клиентов, у кого на момент до преобразования уже был 1 продукт (выглядит как акция для недавно присоединившихся клиентов). Допустим, что наш банк предлагает самые выгодные условия для открытия вклада на всем банковском рынке, если у клиента открыт счет или есть кредит в банке (как раз 1 продукт). Предположим, что наши условия сработали в 15% случаев.
set.seed(666)
test2 = test
test2$NumOfProducts[test2$NumOfProducts == 1] =
sample(c(1, 2),
size = length(test2$NumOfProducts[test2$NumOfProducts == 1]),
replace = T, prob = c(0.85, 0.15))
predTest2 = predict(logreg, test2)$.pred_class
ggplot(data.frame(predTest)) + geom_bar(aes(x = predTest), alpha = 0.5, fill = "red") +
geom_bar(data = data.frame(predTest2), aes(x = predTest2), alpha = 0.5, fill = "blue") +
geom_bar(data = test, aes(x = Exited), alpha = 0.5)
Можем заметить, что после симуляции модель предсказывает, что больше клиентов остается у банка. Красный цвет показывает результаты до симуляции, а синий цвет - после симуляции (фиолетовый получился наложением синего и красного цветов). Следовательно, мы видим, что синего цвета у неушедших клиентов намного больше, поэтому можем сделать вывод о том, что наше предположение о том, что привлечение клиентов путем предложения им нашей акции, оказалось верным.
Давайте также посмотрим на интерактивную визуализацию наших данных до симуляции, чтобы понимать, насколько отличаются ушедшие и оставшиеся клиенты между с собой в рамках количества используемых продуктов.
library(crosstalk)
sharedData <- SharedData$new(final_exited)
bscols(widths = c(3,NA),
list(
filter_checkbox("status", "Ушел или нет", sharedData, ~Exited),
filter_slider("credit score", "Кредитный скоринг", sharedData, ~CreditScore),
filter_slider("age", "Возраст", sharedData, ~Age)
),
plot_ly(sharedData,
x = ~CreditScore, y = ~Age, color = ~as.factor(NumOfProducts),
type = "scatter",
colors = "Set3")
)
В дэшборд я внесу два элемента:
Интерактивную визуализацию с информацией о том, что клиентки (то есть женщины) уходят чаще из банка.
Интерактивную визуализацию о том, насколько отличаются ушедшие и оставшиеся клиенты между с собой в рамках количества используемых продуктов.
Данный дэшборд полезен для понимания нашей “группы риска” и ее дальнейшего анализа. Дэшборд по большей части предназначен для аналитиков данных, которые после полученной информации должны будут спрогнозировать улучшения для данной выборки, чтобы уменьшить отток клиентов.
Я провел кластеризацию, используя k.means и разбиение на 5 кластеров на основе нескольких переменных. В моем случае при установленном мною сиде получилось, что в 4 кластере все клиенты ушли из банка (что и является целевой переменной “Exited”). Еще в этом кластере интересны следующие переменные:
возраст - он в среднем выше, чем в других кластерах
кредитный скоринг клиента - он в среднем меньше, чем в других кластерах
пол - в среднем чаще уходят женщины (вывод сделан на основе того, что Gender_Male меньше половины)
есть ли кредитная карта - у ушедших клиентов в среднем меньше кредитных карт, чем в остальных кластерах, за исключением 5.
Поэтому я решил взять сегмент данных со следующими критериями:
Женщины
Возраст выше среднего
Кредитный скоринг меньше среднего
После выбора группы для анализа были построены две модели: дерево решений и логистическая регрессия. Для дальнейшей работы была выбрана логистическая регрессия, поскольку она выявила больше важных признаков. На основе модели была проведена симуляция количества продуктов, так как данная переменная значилась важной для регрессии и мы еще можем на нее повлиять. Результаты показали, что при использовании нашей “акции” (наш банк предлагает самые выгодные условия для открытия вклада на всем банковском рынке, если у клиента открыт счет или есть кредит в банке) увеличение количества продуктов позволило уменьшить отток клиентов. Задача всей работы выполнена!